(FILECREATED "15-APR-74 03:04:16" STRUCTURE)


  (LISPXPRINT (QUOTE STRUCTUREVARS)
	      T)
  (RPAQQ STRUCTUREVARS ((FNS DAISY SINGLERING STRUCWITH2NODES COPYSTRUC 
			     SINGLERINGS)
	  (FNS PUTLOOPS PUTFVS PUTBIVS INSERTMARKERS)
	  (FNS PUTFVNODE PUTBIVNODE PUTBIVNODES PUTBIVEDGE BIVALENTCHAIN)
	  (FNS CONNECT DISCONNECT)
	  (FNS FREEVALENCESIZE NODEVALENCE VALENCETYPE LISTBYVALENCE COLLECTFV 
	       FINDCTE FIRSTOFNODES LASTOFNODES NODES)
	  (FNS RADICAL? CENTER? ATOMTYPE)
	  (FNS COLLECTUGRAPH COLLECTUGRAPH1)))
(DEFINEQ

(DAISY
(LAMBDA (PART) (PROG (STRUC NODENUMBER) (SETQ STRUC (create STRUCTURE CTABLE
← (LIST (create CTENTRY NODENUM ← 1)) UGRAPH ← (CONS (QUOTE DAISY) PART) 
LASTNODE# ← 1)) (for PAIR in PART do (for I from 1 to (CDR PAIR) do (PUTBIVNODE
STRUC 1 (CAR PAIR)))) (RETURN (LIST STRUC)))))

(SINGLERING
(LAMBDA (N) (create STRUCTURE CTABLE ← (CONS (create CTENTRY NODENUM ← 1 NBRS
← (LIST 2 N)) (NCONC1 (BIVALENTCHAIN 2 (SUB1 N)) (create CTENTRY NODENUM ←
N NBRS ← (LIST 1 (SUB1 N))))) UGRAPH ← (LIST (QUOTE SINGLERING) N) LASTNODE#
← N)))

(STRUCWITH2NODES
(LAMBDA (N AT1 AT2) (PROG ((TEM (COND ((EQ N 2) (SINGLERINGS 2)) (T (CATALOG
(NCONC1 (LISTOF (IDIFFERENCE N 3) 0) 2)))))) (* First get a structure with
two nodes of the right valence) (COND ((AND TEM (type? STRUCTURE (SETQ TEM
(CAR TEM)))) (COND ((OR AT1 AT2) (SETQ TEM (COPYSTRUC TEM)) (replace ATOMTYPE
of (CAR (fetch CTABLE of TEM)) with AT1) (PUTFVNODE TEM 1 (IDIFFERENCE (VALENCE
AT1) N)) (PUTFVNODE TEM 2 (IDIFFERENCE (VALENCE AT2) N)) (replace ATOMTYPE
of (CADR (fetch CTABLE of TEM)) with AT2) (COND ((NEQ AT1 AT2) (replace GROUP
of TEM with (LIST (CAR (fetch GROUP of TEM)))))))) TEM) (T (create STRUCTURE
CTABLE ← (LIST (create CTENTRY NODENUM ← 1 ATOMTYPE ← AT1 NBRS ← (LISTOF N
2) FREEVALENCE ← (COND (AT1 (IDIFFERENCE (VALENCE AT1) N)) (T 0))) (create
CTENTRY NODENUM ← 2 ATOMTYPE ← AT2 NBRS ← (LISTOF N 1) FREEVALENCE ← (COND
(AT2 (IDIFFERENCE (VALENCE AT2) N)) (T 0)))) UGRAPH ← (CONS (QUOTE MBONDS)
N) LASTNODE# ← 2))))))

(COPYSTRUC
(LAMBDA (STRUC) (create STRUCTURE using STRUC CTABLE ← (MAPCAR (fetch CTABLE
of STRUC) (FUNCTION (LAMBDA (CT) (create CTENTRY copying CT)))) GROUP ← (fetch
GROUP of STRUC))))

(SINGLERINGS
(LAMBDA (N) (PROG (TEM TEM2) (COND ((NOT (IGREATERP N 1)) (HELP 
"BAD ARG TO SINGLERINGS" N)) (T (LIST (SINGLERING N)))))))
)
(DEFINEQ

(PUTLOOPS
(LAMBDA (STRUC LLCLLOOPS LLNODE) (* LLCLLOOPS is a list of lists of loop 
compositions - LLNODE is a list of lists of NODES - The corresponding nodes
get the corresponding loops) (for LNODE in LLNODE as LCLLOOP in LLCLLOOPS
do (for NODE in LNODE as CLLOOP in LCLLOOP do (for LOOPPAIR in CLLOOP do (for
I from 1 to (CDR LOOPPAIR) do (for N in NODE do (PUTBIVNODE STRUC N (CAR 
LOOPPAIR))))))) STRUC))

(PUTFVS
(LAMBDA (STRUC FVPART) (* FVPART is a list of fv assignments, where a fv 
assignment is a list, in order of number of fv's, of lists of nodes) (for
LLNODE in FVPART do (for LNODE in LLNODE as NFVS from 1 do (for NODE in LNODE
do (PUTFVNODE STRUC NODE NFVS)))) STRUC))

(PUTBIVS
(LAMBDA (STRUC LNBIVS LLEDGE) (* LLEDGE is a list of lists of edges - LNBIVS
is a list of number of bivalents) (for LEDGE in LLEDGE as NBIVS in LNBIVS
do (for EDGE in LEDGE do (PUTBIVEDGE STRUC EDGE NBIVS))) STRUC))

(INSERTMARKERS
(LAMBDA (STRUC CLL LLLNODE) (for CL in CLL as LLNODE in LLLNODE do (for PAIR
in CL as LNODE in LLNODE do (for NODE in LNODE do (replace ATOMTYPE of (FINDCTE
NODE STRUC) with (CAR PAIR))))) STRUC))
)
(DEFINEQ

(PUTFVNODE
(LAMBDA (STRUC NODE NUMFVS) (SETQ NODE (FINDCTE NODE (fetch CTABLE of STRUC)))
(replace FREEVALENCE of NODE with (IPLUS (fetch FREEVALENCE of NODE) NUMFVS))
STRUC))

(PUTBIVNODE
(LAMBDA (STRUC NODENUM NUMBIVS) (* Puts a loop of NUMBIVS bivalents on node
NODENUM in structure STRUC) (PUTBIVNODES STRUC NODENUM NODENUM NUMBIVS)))

(PUTBIVNODES
(LAMBDA (STRUC NODE1 NODE2 NUMBIVS) (* Inserts a chain of NUMBIVS bivalents
between NODE1 and NODE2 in the structure STRUC; if NODE1=NODE2, this adds
a loop of NUMBIVS bivalents) (OR (AND (type? STRUCTURE STRUC) (SMALLP NODE2)
(SMALLP NODE1) (SMALLP NUMBIVS) (fetch CTABLE of STRUC)) (HELP (QUOTE (BAD
ARG TO BUTBIVNODE)))) (COND ((ZEROP NUMBIVS)) (T (PROG ((LASTNUM (fetch 
LASTNODE# of STRUC)) (CTE1 (FINDCTE NODE1 STRUC)) (CTE2 (FINDCTE NODE2 STRUC))
TEM) (replace NBRS of CTE1 with (CONS (ADD1 LASTNUM) (fetch NBRS of CTE1)))
(* connect this node to the chain beginning) (NCONC (fetch CTABLE of STRUC)
(COND ((EQ NUMBIVS 1) (SETQ TEM LASTNUM) (LIST (create CTENTRY NODENUM ← (ADD1
LASTNUM) NBRS ← (LIST NODE1 NODE2)))) (T (SETQ TEM (SUB1 (IPLUS LASTNUM NUMBIVS)))
(SETQ LASTNUM (ADD1 LASTNUM)) (CONS (create CTENTRY NODENUM ← LASTNUM NBRS
← (LIST NODE1 (ADD1 LASTNUM))) (NCONC1 (BIVALENTCHAIN (ADD1 LASTNUM) TEM)
(create CTENTRY NODENUM ← (ADD1 TEM) NBRS ← (LIST NODE2 TEM))))))) (* Create
chain) (replace NBRS of CTE2 with (CONS (SETQ LASTNUM (ADD1 TEM)) (fetch NBRS
of CTE2))) (replace LASTNODE# of STRUC with LASTNUM)))) STRUC))

(PUTBIVEDGE
(LAMBDA (STRUC EDGE NUMBIVS) (COND ((ZEROP NUMBIVS) STRUC) (T (DISCONNECT
(FINDCTE (CAR EDGE) STRUC) (FINDCTE (CDR EDGE) STRUC)) (PUTBIVNODES STRUC
(CAR EDGE) (CDR EDGE) NUMBIVS)))))

(BIVALENTCHAIN
(LAMBDA (START STOP) (for I from START to STOP collect (create CTENTRY NODENUM
← I NBRS ← (LIST (SUB1 I) (ADD1 I))))))
)
(DEFINEQ

(CONNECT
(LAMBDA (X Y) (OR (AND X Y) (HELP "BAD ARG TO CONNECT")) (replace NBRS of
X with (CONS (fetch NODENUM of Y) (fetch NBRS of X))) (COND ((NEQ X Y) (replace
NBRS of Y with (CONS (fetch NODENUM of X) (fetch NBRS of Y)))))))

(DISCONNECT
(LAMBDA (X Y) (REPLACE NBRS OF X WITH (DELETE (FETCH NODENUM OF Y) (FETCH
NBRS OF X))) (REPLACE NBRS OF Y WITH (DELETE (FETCH NODENUM OF X) (FETCH NBRS
OF Y)))))
)
(DEFINEQ

(FREEVALENCESIZE
(LAMBDA (S) (COND ((type? STRUCTURE S) (for X in (fetch CTABLE of S) sum (IPLUS
(for Y in (fetch NBRS of X) count (EQ Y (QUOTE FV))) (fetch FREEVALENCE of
X)))) ((AND (type? STRUCFORM S) (EQ (fetch FN of S) (QUOTE ATTACHFVS))) (for
FVL in (CAR (fetch ARGS of S)) sum (for X in FVL as I from 1 sum (ITIMES I
X)))) ((type? STRUCFORM S) (COND ((EQ (CAR (FETCH FORM OF S)) (QUOTE RINGS))
(COMPUTEFV (CADR (FETCH FORM OF S)) (CADDR (FETCH FORM OF S)))) (T (HELP))))
(T (HELP "VALENCE" S)))))

(NODEVALENCE
(LAMBDA (NODE) (COND ((NULL NODE) (ERROR (QUOTE (NULL NODE GIVEN TO NODEVALENCE))))
((type? CTENTRY NODE) (IPLUS (FLENGTH (fetch NBRS of NODE)) (fetch FREEVALENCE
of NODE))) (T (NODEVALENCE (FINDCTE (CAR NODE) (CDR NODE)))))))

(VALENCETYPE
(LAMBDA (S I) (for NODE in (fetch CTABLE of S) when (EQ I (NODEVALENCE NODE))
rcollect (fetch NODENUM of NODE))))

(LISTBYVALENCE
(LAMBDA (S) (PROG (LST (LEN 1) TEM) (for X in (fetch CTABLE of S) do (SETQ
TEM (NODEVALENCE X)) (while (IGREATERP TEM LEN) do (SETQ LST (CONS NIL LST))
(SETQ LEN (ADD1 LEN))) (RPLACA (SETQ TEM2 (NTH LST (ADD1 (IDIFFERENCE LEN
TEM)))) (CONS (fetch NODENUM of X) (CAR TEM2)))) (RETURN (DREVERSE LST)))))

(COLLECTFV
(LAMBDA (S) (for CT in (fetch CTABLE of S) join (NCONC (for X in (fetch NBRS
of CT) when (EQ X (QUOTE FV)) collect (fetch NODENUM of CT)) (LISTOF (fetch
FREEVALENCE of CT) (fetch NODENUM of CT))))))

(FINDCTE
(LAMBDA (NODE STRUC) (COND ((NUMBERP NODE) (AND (type? STRUCTURE STRUC) (SETQ
STRUC (fetch CTABLE of STRUC))) (for L in STRUC suchthat (EQ (fetch NODENUM
of L) NODE))) ((NUMBERP STRUC) (FINDCTE STRUC NODE)) (T (ERROR (QUOTE (BAD
ARGUMENTS TO FINDCTE)) STRUC)))))

(FIRSTOFNODES
(LAMBDA (X) (fetch NODENUM of (CAR (fetch CTABLE of X)))))

(LASTOFNODES
(LAMBDA (X) (fetch NODENUM of (CAR (LAST (fetch CTABLE of X))))))

(NODES
(LAMBDA (STRUC) (MAPCAR (FETCH CTABLE OF STRUC) (FUNCTION (LAMBDA (X) (FETCH
NODENUM OF X))))))
)
(DEFINEQ

(RADICAL?
(LAMBDA (X) (AND X (CENTER? (fetch CENTER of X)) (EVERY (fetch ATTACHEDRADS
of X) (FUNCTION (LAMBDA (Y) (AND (NUMBERP (CDR Y)) (RADICAL? (CAR Y)))))))))

(CENTER?
(LAMBDA (X) (COND ((NLISTP X) (OR (NULL X) (VALENCE X))) (T (AND (OR (NULL
(fetch AFFLINK of X)) (NUMBERP (fetch AFFLINK of X))) (type? STRUCTURE (fetch
RADSTRUC of X)) (EVERY (fetch CUFFLINKS of X) (FUNCTION (LAMBDA (Y) (EVERY
Y (FUNCTION NUMBERP))))))))))

(ATOMTYPE
(LAMBDA (CTE) (IF NLISTP CTE:MARKERS THEN CTE:MARKERS ELSE CTE:MARKERS:ATOMTYPE))
)
)
(DEFINEQ

(COLLECTUGRAPH
(LAMBDA (S) (CLCREATE (COND ((type? STRUCTURE S) (LIST (fetch UGRAPH of S)))
(T (COLLECTUGRAPH1 S))))))

(COLLECTUGRAPH1
(LAMBDA (RAD) (NCONC (COND ((ATOM (fetch CENTER of RAD)) NIL) (T (LIST (fetch
UGRAPH of (fetch RADSTRUC of (fetch CENTER of RAD)))))) (for X in 
RAD:ATTACHEDRADS join (for I from 1 to X::1 join (COLLECTUGRAPH1 X:1))))))
)
STOP